home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / System source / StrUtilities < prev    next >
Text File  |  1992-12-31  |  7KB  |  328 lines
  1. \ Utility subroutines for the String+ class.
  2. \ Separated from String+ and revised - Aug 87.
  3. \ Error checking improved - May 88.
  4. \ Version for Mops - June 89.
  5.  
  6. 0    value    CASE?    \ True if case to be significant in comparisons
  7.  
  8.   $ D    constant    RET    \ Carriage return
  9.     0    value        $START    \ Addr of start of (chars of) current string.
  10.  
  11.  
  12. \        ========  TRTBL class  ========
  13.  
  14. \ Translate tables allow very fast searching of strings for specified sets
  15. \ of characters.  In effect we are separating the specification of what we
  16. \ are searching for from the actual search operation itself.  This allows an
  17. \ uncluttered and extremely fast search operation (the SCAN: and <SCAN: methods
  18. \ of class STRING+), and it also allows a very flexible (and easily extensible)
  19. \ choice of what to search for.  The setup time for translate tables can
  20. \ generally be factored out of inner loops, or done at compile time, and is
  21. \ quite fast, anyway.
  22. \ We first define a class (trtbl) which is needed to define the table mapping
  23. \ lower case letters to upper case.  This table is then used by some of
  24. \ the methods in the trtbl class proper.
  25.  
  26. :class (TRTBL)  super{ object }
  27.  
  28.     int    COUNT
  29.   256    bytes    THETBL
  30.  
  31. :m TBL:  addr: theTbl  ;m
  32.  
  33. :m >UC:
  34.     addr: theTbl  & A  +
  35.     addr: theTbl  & a  +
  36.     26  cmove  ;m
  37.  
  38. :mcode TRANSC:    \ ( c -- c' )  Translates 1 char using the table.
  39.     MOVE    (SP),D0
  40.     MOVE.B    2(A2,D0.W),3(SP)
  41. ;mcode
  42.  
  43. ;class
  44.  
  45.  
  46. (trtbl) UCTBL        \ Maps lower case letters to upper case, and
  47.                     \  leaves everything else unchanged.
  48.  
  49. : XX
  50.     0   tbl: UCtbl  256  bounds
  51.     DO  dup i c!  1+  LOOP
  52.     drop  >uc: UCtbl  ;
  53.  
  54. xx  forget xx
  55.  
  56. :code (SELC)        \ Subroutine used by SELCHAR: and SELCHARNC:.
  57.     ADDQ.W    #1,(A2)
  58.     MOVE.W    (A2)+,D1
  59.     MOVE.B    D1,0(A2,D2.W)
  60. ;code
  61.  
  62.  
  63. :class TRTBL  super{ (trtbl) }
  64.  
  65. :mcode CLEAR:
  66.     loc
  67.     CLR.W    (A2)+
  68.     MOVEQ    #63,D0
  69. loop    CLR    (A2)+
  70.     DBRA    D0,loop
  71. ;mcode
  72.  
  73.  
  74. :m PUT:  { addr len -- }
  75.     addr  addr: theTbl  len 256 min  cmove  ;m
  76.  
  77.  
  78. :mcode SELCHARS:    \ ( addr len -- )
  79.     loc
  80.     POP    D0        ; D0 = len
  81.     POP    A1        ; A1 = addr
  82.     ADD    D0,A1
  83.     MOVE    D0,D1
  84.     ADD.W    (A2),D1
  85.     MOVE.W    D1,(A2)+
  86.     MOVEQ    #0,D2
  87.     BRA.S    lptst
  88.  
  89. loop    MOVE.B    -(A1),D2
  90.     MOVE.B    D1,0(A2,D2.W)
  91.     SUBQ    #1,D1
  92. lptst    DBRA    D0,loop
  93. ;mcode
  94.  
  95.  
  96. :mcode SELCHAR:        \ ( c -- )
  97.     POP    D2
  98.     BSR    dic[(selc)]
  99. ;mcode
  100.  
  101.  
  102. :mcode SELCHARNC:    \ ( c -- )  "SelChar, no case".
  103.         \ Selects a character, and if it is a letter,
  104.         \ enters the same value in the LC and UC positions of the
  105.         \ table, so that case will in effect be ignored when the
  106.         \ table is used.
  107.     POP    D2
  108.     LEA    10(dic[UCtbl]),A0    ; Offset is offs to ^obj, plus 2
  109.     MOVE.B    0(A0,D2.W),D2        ; Convert char to upper case
  110.     BSR    dic[(selc)]
  111.     CMPI.B    #$41,D2
  112.     BLT.S    end
  113.     CMPI.B    #$5A,D2
  114.     BGT.S    end
  115.     ORI.B    #$20,D2
  116.     MOVE.B    D1,0(A2,D2.W)
  117. end
  118. ;mcode
  119.     
  120. :mcode SELRANGE:    \ ( lo hi -- )
  121.     loc
  122.     ADDQ    #2,A2
  123.     POP    D0        ; hi
  124.     POP    D1        ; lo
  125.     ADD    D1,A2
  126.     SUB    D1,D0
  127.     BLT.S    end
  128.     MOVEQ    #1,D2
  129.  
  130. loop    MOVE.B    D2,(A2)+
  131. lptst    DBRA    D0,loop
  132. end
  133. ;mcode
  134.  
  135. :mcode INVERT:
  136.     loc
  137.     ADDQ    #2,A2
  138.     MOVEQ    #255,D0
  139. loop    TST.B    (A2)
  140.     SEQ    (A2)+
  141.     DBRA    D0,loop
  142. ;mcode
  143.  
  144. ;class
  145.  
  146.  
  147. \ GETIT is a code subroutine to get the address and length of the active part
  148. \ of the current string.  A2 points to the string object.
  149. \
  150. \ Returns:
  151. \    A0    addr of first char of the active part
  152. \    D0    length of active part
  153. \    D2 (lo half)  high 16 bits of length - may be used as an outer loop
  154. \               counter in DBxx loops.
  155. \    CC    result of subtracting POS from LIM to get the length.
  156. \     $start    addr of the start of the whole string
  157. \
  158. \ If this length turns out to be negative, $CHK is called to give an error trap.
  159. \ We don't take a length of zero as an error (there are some situations where
  160. \ this is quite legitimate).  Those operations which don't like a zero
  161. \ length can call $CHK themselves.
  162. \ This subroutine must be called from a method, with A2 undisturbed.
  163. \ Only A0, A2, D0 and D2 are altered.
  164.  
  165. :code GETIT
  166.     loc
  167.     MOVE    (A2),A0    ; A0 = handle
  168.     MOVE    (A0),A0    ; Dereference it - addr of start of string
  169.     MOVE    A0,dic[$start]    ; Leave in $start
  170.     ADD    8(A2),A0    ; Add POS, giving addr of start of active part
  171.     MOVE    12(A2),D0    ; D0 = LIM
  172.     SUB    8(A2),D0    ; Subtract POS, giving length
  173.     MOVE    D0,D2
  174.     SWAP    D2    ; Hi 16 bits to lo half of D2
  175.     TST    D0    ; Test length
  176.     BGE.S    end
  177.     JMP    dic[$fail]    ; If negative, error
  178. end
  179. ;code
  180.  
  181.  
  182. \ CCMP is the primitive subroutine for performing string comparison.
  183. \    A0 -> string2
  184. \    A1 -> string1
  185. \    D0 = length
  186. \ Assumes length is less than 64K.
  187. \ Returns with the CC set appropriately.
  188. \ Uses those registers.
  189.  
  190. :code CCMP
  191.     loc
  192.     SUBQ    #1,D0
  193.     BMI.S    equal
  194.     TST    dic[case?]
  195.     BEQ.S    nocase
  196.  
  197. loop1    CMPM.B    (A0)+,(A1)+
  198.     DBNE    D0,loop1
  199.     RTS
  200.  
  201. equal    CMP.W    D0,D0
  202.     RTS
  203.  
  204. nocase    MOVEM    D2/D3/A2,-(SP)
  205.     MOVEQ    #0,D2
  206.     LEA    10(dic[UCtbl]),A2
  207.  
  208. loop2    CMPM.B    (A0)+,(A1)+
  209. lp2tst    DBNE    D0,loop2
  210.     BEQ.S    end
  211.     MOVE.B    -1(A1),D2
  212.     MOVE.B    0(A2,D2.W),D3
  213.     MOVE.B    -1(A0),D2
  214.     CMP.B    0(A2,D2.W),D3
  215.     BEQ.S    lp2tst
  216. end    MOVEM    (SP)+,D2/D3/A2
  217. ;code
  218.  
  219.  
  220. \ CSCH and <CSCH are the primitive subroutines for searching for a single
  221. \ character.
  222. \    A0 -> string
  223. \    D0 = length
  224. \    D2 = length (hi)
  225. \    D1 = char (rest must be zero)
  226. \ Both routines return with the CC set appropriately.
  227.  
  228. :code CSCH
  229.     loc
  230.     TST    dic[case?]
  231.     BEQ.S    nocase
  232.     BRA.S    lp1tst    ; Note: we enter the loop with "not equal"
  233.  
  234. loop1    CMP.B    (A0)+,D1
  235. lp1tst    DBEQ    D0,loop1
  236.     DBEQ    D2,loop1
  237.     RTS
  238.  
  239. nocase    MOVEM    D1/D2/A2,-(SP)
  240.     LEA    10(dic[UCtbl]),A2
  241.     MOVE.B    0(A2,D1.W),D1
  242.     MOVEQ    #1,D2    ; Set "not equal", clear top 3 bytes of D2
  243.     BRA.S    lp2tst
  244.  
  245. outer    MOVE    D2,4(SP)
  246. loop2    MOVE.B    (A0)+,D2
  247.     CMP.B    0(A2,D2.W),D1
  248. lp2tst    DBEQ    D0,loop2
  249.     MOVEM    4(SP),D2    ; Recover outer loop counter, preserving CC
  250.     DBEQ    D2,outer
  251.     MOVEM    (SP)+,D1/D2/A2
  252. end
  253. ;code
  254.  
  255. :code <CSCH
  256.     loc
  257.     TST    dic[case?]
  258.     BEQ.S    nocase
  259.     BRA.S    lp1tst        ; Note: we enter the loop with "not equal"
  260.  
  261. loop1    CMP.B    -(A0),D1
  262. lp1tst    DBEQ    D0,loop1
  263.     DBEQ    D2,loop1
  264.     BRA.S    end
  265.  
  266. nocase    MOVEM    D1/D2/A2,-(SP)
  267.     LEA    10(dic[UCtbl]),A2
  268.     MOVE.B    0(A2,D1.W),D1
  269.     MOVEQ    #1,D2        ; Set "not equal", clear top 3 bytes of D2
  270.     BRA.S    lp2tst
  271.  
  272. outer    MOVE    D2,4(SP)
  273. loop2    MOVE.B    -(A0),D2
  274.     CMP.B    0(A2,D2.W),D1
  275. lp2tst    DBEQ    D0,loop2
  276.     MOVEM    4(SP),D2    ; Recover outer loop counter, preserving CC
  277.     DBEQ    D2,outer
  278.     MOVEM    (SP)+,D1/D2/A2
  279. end
  280. ;code
  281.  
  282.  
  283. \ CMPSTR ( addr1 len1 addr2 len2 -- n ) compares 2 strings.
  284. \ Case is significant if CASE? is set to true.
  285. \ Returns:
  286. \  -1   first string low
  287. \   0   strings are equal
  288. \   1   first string high
  289. \ We assume the lengths are both less than 64K.
  290. \
  291. \ Uses D0,D1,D2,A0,A1.
  292.  
  293. :code CMPSTR
  294.     loc
  295.     POP    D0        ; D0 = len2
  296.     POP    A0        ; A0 = addr2
  297.     POP    D1        ; D1 = len1
  298.     MOVE    (SP),A1        ; A1 = addr1
  299.     MOVEQ    #0,D2        ; D2 will hold return result
  300.     CMP.W    D1,D0        ; Compare lengths
  301.     BEQ.S    docmp
  302.     BHI.S    op2long
  303.     MOVEQ    #1,D2
  304.     BRA.S    docmp
  305.  
  306. op2long    MOVE.W    D1,D0
  307.     MOVEQ    #-1,D2
  308.  
  309. docmp    BSR    dic[ccmp]
  310.     BEQ.S    end
  311.     SMI    D2
  312.     ORI.B    #1,D2
  313.     EXT.W    D2
  314.     EXT.L    D2
  315. end    MOVE    D2,(SP)
  316. ;code
  317.  
  318.  
  319. \ INSTEAD ( c-old c-new -- )  may be used just after a SCON is defined.
  320. \ Within the SCON, it replaces any occurrences of c-old with c-new.  This 
  321. \ operation is useful for creating SCONs containing special characters
  322. \ such as tab.
  323.  
  324. : INSTEAD  { c-old c-new -- }
  325.     latest name> ex-gen  bounds    \ SCONs use DOES> so require EX-GEN
  326.     DO   i c@ c-old = IF  c-new i c!  THEN
  327.     LOOP  ;
  328.